home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / alpha.t next >
Encoding:
Text File  |  1989-06-30  |  21.7 KB  |  549 lines
  1. (herald (front_end alpha)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Macro expansion, alphatization, and creating the node tree.
  28. ;;;============================================================================
  29.  
  30. ;;; The syntax table containing all special forms of interest to the
  31. ;;; compiler.
  32.  
  33. (define primitive-syntax-table
  34.   (make-syntax-table false 'primitive-syntax-table))
  35.  
  36. ;;; A table of compilator procedures to handle instances of special forms the
  37. ;;; compiler knows about.
  38.  
  39. (define primitive-handler-table
  40.   (make-table 'primitive-handler-table))
  41.  
  42. ;;;    This translates expressions into node trees.  Expressions include
  43. ;;; symbols, pairs, variable records, primops, nodes, and self-evaluating
  44. ;;; things.  All ->NODE actually does is to dispatch to other procedures.
  45. ;;;
  46. ;;; SYNTAX is the syntax table to be used in compiling the expression.
  47. ;;; SHAPE is an object that keeps track of the environment.
  48. ;;;
  49. ;;; Three values are returned: the top of the node tree created and the 
  50. ;;; node tree's continuation's parent and role.  The continuation itself is
  51. ;;; EMPTY.  If the top of the tree is not a call node the contination's parent
  52. ;;; and role are undefined.
  53. ;;;
  54. ;;; Thus if node C1 is to be the continuation of the expression (+ A B) :
  55. ;;;      (RECEIVE (NODE C-PARENT C-ROLE)
  56. ;;;               (->NODE '(+ A B) <syntax> <shape>)
  57. ;;;        (RELATE C-ROLE C-PARENT C1))
  58.  
  59. (define (->node exp syntax shape)
  60.   (cond ((variable? exp)
  61.          (return (create-reference-node exp) nil nil))
  62.         ((primop? exp)
  63.          (return (create-primop-node exp) nil nil))
  64.         ((node? exp)
  65.          (return exp nil nil))
  66.         ((pair? exp)
  67.          (pair->node exp syntax shape))
  68.         (else
  69.          (->node ((atom-expander syntax) exp) syntax shape))))
  70.  
  71. ;;; More dispatching
  72.  
  73. (define (pair->node exp syntax shape)
  74.   (let ((head (car exp)))
  75.     (cond ((not (proper-list? exp)) 
  76.            (->node (syntax-error '"expression is an improper list~%  ~S" exp)
  77.                    syntax shape))
  78.           ((syntax-descriptor? head)
  79.            (special-form->node head exp syntax shape))
  80.           ((syntax-table-entry syntax head)
  81.            => (lambda (desc)
  82.                 (special-form->node desc exp syntax shape)))
  83.           (else
  84.            (make-call exp syntax shape)))))
  85.  
  86. ;;; Does syntax error checking, primitive syntax dispatch, and macro 
  87. ;;; expansion.  The error checking is done by CHECK-SPECIAL-FORM, a T system
  88. ;;; procedure.
  89.  
  90. (define (special-form->node descr exp syntax shape)
  91.   (let ((proc (table-entry primitive-handler-table descr))
  92.         (new-exp (check-special-form-syntax descr exp)))
  93.     (cond ((neq? exp new-exp)
  94.            ;; An error was reported, and luser gave us a new form.
  95.            (->node new-exp syntax shape))
  96.           (proc
  97.            (proc exp syntax shape))
  98.           ((macro-expander? descr)
  99.            (->node (expand-macro-form descr exp syntax) syntax shape))
  100.           (else
  101.            (syntax-error "special form unknown to this compiler~%  ~S" exp)))))
  102.  
  103. ;;;===========================================================================
  104. ;;;                    SPECIAL FORMS
  105. ;;;===========================================================================
  106.  
  107. ;;; Syntax for defining compilators for the special forms that the compiler
  108. ;;; recognizes.  The syntax is:
  109. ;;;
  110. ;;; (DEFINE-COMPILER-SYNTAX (<syntax-name> . <argument form>)
  111. ;;;                         (<syntax table variable> <shape variable>)
  112. ;;;   . <expression->node translation code>)
  113. ;;;
  114. ;;; This puts a syntax descriptor into PRIMITIVE-SYNTAX-TABLE and a handler in
  115. ;;; PRIMITIVE-HANDLER-TABLE using the syntax descriptor as a key.  
  116.  
  117. (define-local-syntax (define-compiler-syntax pattern vars . body)
  118.   (let* ((name (car pattern))
  119.          (sym (concatenate-symbol 'syntax/ name))
  120.          (exp (generate-symbol 'exp)))
  121.     `(let ((descr (syntax-table-entry (env-syntax-table t-implementation-env)
  122.                                       ',name)))
  123.        (set (syntax-table-entry primitive-syntax-table ',name) descr)
  124.        (set (table-entry primitive-handler-table descr)
  125.             (lambda (,exp . ,vars)
  126.               (ignorable . ,vars)
  127.               (destructure ((,(cdr pattern) (cdr ,exp)))
  128.                 ,@body)))
  129.        (define ,sym descr))))
  130.  
  131. ;;; (QUOTE <blah>)
  132. ;;; => a literal node containing <blah>.
  133.  
  134. (define-compiler-syntax (quote value) (syntax shape)
  135.   (return (create-literal-node (free-copy-tree value)) nil nil))
  136.  
  137. ;;; (LAMBDA vars . body)
  138. ;;; => a lambda node, courtesy of ALPHA-LAMBDA
  139.  
  140. (define-compiler-syntax (lambda vars . body) (syntax shape)
  141.   (alpha-lambda 'p vars body syntax shape))
  142.  
  143. ;;; Aaaarrggghh!!!!
  144.  
  145. (define-compiler-syntax (named-lambda name vars . body) (syntax shape)
  146.   (alpha-lambda name vars body syntax shape))
  147.  
  148. ;;; Variable structures are created for the variables (including the
  149. ;;; continuation variable) and added to the shape (not including the
  150. ;;; continuation variable).  The body is converted into a call node with
  151. ;;; its continuation being the continuation variable.  The variables
  152. ;;; are then removed from the shape and have any declarations processed
  153. ;;; (this includes adding cells for variables that are set).
  154.  
  155. (define (alpha-lambda name var-names body syntax shape)
  156.   (let* ((vars (map! (lambda (name)
  157.                        (if (null? name) nil (create-variable name)))
  158.                      (fix-vars (cons-from-freelist 'k var-names))))
  159.          (real-vars (cons-from-freelist (car vars) (cddr vars))))
  160.     (bind-variables shape real-vars)
  161.     (let ((node (create-lambda-node name vars)))
  162.       (receive (value-node c-parent c-role)
  163.                (make-block body syntax shape)
  164.         (relate lambda-body node value-node)
  165.         (relate c-role c-parent (create-reference-node (cadr vars)))
  166.         (unbind-variables shape real-vars)
  167.         (walk (lambda (var)
  168.                 (cond (var
  169.                        (process-lexical-declarations var)
  170.                        (cond ((memq? 'lexical (variable-flags var))
  171.                               (introduce-cell var)
  172.                               (modify (variable-flags var)
  173.                                       (lambda (l) (delq! 'lexical l))))))))
  174.               vars)
  175.         (return-to-freelist real-vars)
  176.         (return node nil nil)))))
  177.  
  178. ;;; Makes a proper list out of VARS by putting the last CDR onto the front.
  179. ;;; (v1 v2 ... vN . X) => (X v1 v2 ... vN)
  180.  
  181. (define (fix-vars vars)
  182.   (do ((vars vars (cdr vars))
  183.        (res '() (cons-from-freelist (car vars) res)))
  184.       ((atom? vars)
  185.        (cons vars (reverse! res)))))
  186.  
  187. ;;; VARIABLE-VALUE
  188.  
  189. (define-compiler-syntax (variable-value name) (syntax shape)
  190.   (return (create-reference-node (obtain-variable shape name)) nil nil))
  191.  
  192. ;;; SET-VARIABLE-VALUE  VAR-LOCATIVE  LSET  DEFINE-VARIABLE-VALUE
  193. ;;; Binding information is added to the shape and a call to the appropriate
  194. ;;; primop is returned.  In the case of LSET and DEFINE-VARIABLE-VALUE a
  195. ;;; warning is issued if the name being defined is already lexically bound.
  196.  
  197. (define-compiler-syntax (set-variable-value name value) (syntax shape)
  198.   (let ((var (add-definition shape name 'set)))
  199.     (make-call `(,primop/*set-var ,var ,value) syntax shape)))
  200.  
  201. (define-compiler-syntax (var-locative name) (syntax shape)
  202.   (let ((var (add-definition shape name 'set)))
  203.     (make-call `(,primop/*locative ,var) syntax shape)))
  204.  
  205. (define-compiler-syntax (lset-variable-value name value) (syntax shape)
  206.   (global-variable-set 'lset primop/*lset name value syntax shape))
  207.  
  208. (define-compiler-syntax (define-variable-value name value) (syntax shape)
  209.   (global-variable-set 'define primop/*define name value syntax shape))
  210.  
  211. (define (global-variable-set variant primop name value syntax shape)
  212.   (let ((var (add-definition shape name variant)))
  213.     (cond ((and (variable? var)
  214.                 (variable-binder var))
  215.            (user-message 'warning
  216.                          '"lexically bound variable ~S is being ~A"
  217.                          '"the variable will be set instead"
  218.                          (variable-name var)
  219.                          (if (eq? 'lset (primop.definition-variant primop))
  220.                              '"lset"
  221.                              '"defined"))
  222.            (make-call `(,primop/*set-var ,var ,value) syntax shape))
  223.           (else
  224.            (make-call `(,primop ,var ,value) syntax shape)))))
  225.  
  226. ;;; (DECLARE key . stuff)
  227. ;;; Uses DECLARATION-HANDLER-TABLE to deal with declarations.  A literal node
  228. ;;; 'DECLARE is returned.
  229.  
  230. (define-compiler-syntax (declare key . stuff) (syntax shape)
  231.   (cond ((table-entry declaration-handler-table key)
  232.          => (lambda (handler)
  233.               (handler stuff shape)))
  234.         (else
  235.          (orbit-warning "ignoring unknown declaration type ~S"
  236.                         `(declare ,key . ,stuff))))
  237.   (return (create-literal-node 'declare) nil nil))
  238.  
  239. ;;; (PRIMOP id formals . clauses)
  240. ;;;   The special form for introducing primitive operations.  The primop is
  241. ;;; constructed, compiled, installed and added to the expression.
  242. ;;;   The name should be changed to stop all the warning messages for PRIMOP
  243. ;;; variables.
  244.  
  245. (define-compiler-syntax (primop id formals . clauses) (syntax shape)
  246.   (let ((primop (eval (primop-code id formals clauses) orbit-env)))
  247.     (set (primop.source primop) clauses)
  248.     (add-new-primop shape primop)
  249.     (make-call `(,primop/*primop ,primop) syntax shape)))
  250.  
  251. ;;; (IF p c a)
  252. ;;; => ((LAMBDA (J)
  253. ;;;       (PRIMOP/CONDITIONAL (LAMBDA () (J C))
  254. ;;;                           (LAMBDA () (J A))
  255. ;;;                           PRIMOP/TEST
  256. ;;;                           PRIMOP/TRUE?
  257. ;;;                           P))
  258. ;;;     <cont>)
  259.  
  260. (define-compiler-syntax (if tested con . maybe-alt) (syntax shape)
  261.   (let ((alt (if (null? maybe-alt) primop/undefined (car maybe-alt))))
  262.     (let* ((j-var (create-variable 'j))
  263.            (j-lambda (create-lambda-node 'p (flist2 nil j-var '())))
  264.            (j-call (create-call-node 2 1))
  265.            (call (list primop/conditional
  266.                        (thunkify con j-var syntax shape)
  267.                        (thunkify alt j-var syntax shape)
  268.                        primop/test
  269.                        primop/true?
  270.                        tested))
  271.            (c-call (make-call-with-exits 2 call syntax shape)))
  272.       (relate call-proc j-call j-lambda)
  273.       (relate lambda-body j-lambda c-call)
  274.       (return j-call j-call (call-arg 1)))))
  275.  
  276. ;;; Turn EXP into a thunk that calls CONT-VAR when it returns.
  277.  
  278. (define (thunkify exp cont-var syntax shape)
  279.   (let ((l-node (create-lambda-node 'c (flist1 nil '()))))
  280.     (receive (call c-parent c-role)
  281.              (make-block (list exp) syntax shape)
  282.       (relate lambda-body l-node call)
  283.       (relate c-role c-parent (create-reference-node cont-var))
  284.       l-node)))
  285.  
  286. ;;; (LABELS ((v1 e1) (v2 e2) ... (vn en)) . body)
  287. ;;; => (PRIMOP/Y (LAMBDA (K v1 v2 ... vn)
  288. ;;;                (K (LAMBDA () . body)
  289. ;;;                   (LAMBDA (C1) (C1 e1))
  290. ;;;                   (LAMBDA (C2) (C2 e2))
  291. ;;;                   ...
  292. ;;;                   (LAMBDA (Cn) (Cn en)))))
  293. ;;; If the specs are empty this is just BLOCK
  294.  
  295. (define-compiler-syntax (labels specs . body) (syntax shape)
  296.   (cond ((null? specs)
  297.          (make-block body syntax shape))
  298.         (else
  299.          (receive (vars vals)
  300.                   (parse-labels-specs specs)
  301.            (make-y-call vars vals body syntax shape)))))
  302.  
  303. ;;; This binds the variables, creates the PRIMOP/Y call, and then unbinds
  304. ;;; the variables.
  305.  
  306. (define (make-y-call vars vals body syntax shape)
  307.   (bind-variables shape vars)
  308.   (receive (b-call c-parent c-role)
  309.            (make-block body syntax shape)
  310.     (receive (args b-call)
  311.              (make-y-args vars vals b-call syntax shape)
  312.       (unbind-variables shape vars)
  313.       (let-nodes ((b-lambda (#f c1) b-call)
  314.                   (y-lambda (#f c2 . vars) ((* c2) 0 (^ b-lambda) . args)))
  315.         (let ((call (create-call-node 3 1)))
  316.           (relate call-proc call (create-primop-node primop/y))
  317.           (relate (call-arg 2) call y-lambda)
  318.           (relate c-role c-parent (create-reference-node c1))
  319.           (walk (lambda (var)
  320.                   (if var (process-lexical-declarations var)))
  321.                 vars)
  322.           (return call call (call-arg 1)))))))
  323.  
  324. ;;; Transform the VALS into thunks.  If a variable is set a cell introduced to
  325. ;;; hold the value and a call is added to the body to set the intitial value.
  326.  
  327. (define (make-y-args vars vals b-call syntax shape)
  328.   (let ((thunks (map (lambda (val)
  329.                        (->value-node `(,syntax/lambda () ,val) syntax shape))
  330.                      vals)))
  331.     (iterate loop ((vars vars) (thunks thunks)
  332.                    (args '()) (b-call b-call))
  333.       (cond ((null? vars)
  334.              (return (reverse! args) b-call))
  335.             ((or (not (car vars))
  336.                  (not (memq? 'lexical (variable-flags (car vars)))))
  337.              (loop (cdr vars) (cdr thunks)
  338.                    (cons (car thunks) args) b-call))
  339.             (else
  340.              (let ((var (car vars)))
  341.                (hack-references var var)
  342.                (set (variable-flags var)
  343.                     (delq! 'lexical (variable-flags var)))
  344.                (loop (cdr vars) (cdr thunks)
  345.                      (cons (labels-make-cell-thunk) args)
  346.                      (add-set-contents b-call var (car thunks)))))))))
  347.  
  348. (define (add-set-contents call var thunk)
  349.   (let-nodes ((c1 ((! thunk) 0 (^ l1)))
  350.                (l1 (#f v) (($ primop/set-location)
  351.                            1
  352.                            (^ l2) ($ primop/cell-value) (* v) (* var)))
  353.                 (l2 (#f) call))
  354.     c1))
  355.  
  356. ;;; Parse SPECS into a list of variables and a list of value expressions.
  357. ;;; The SPECS may have implicit lambdas that need to be made explicit.
  358.  
  359. (define (parse-labels-specs specs)
  360.   (return (free-map (lambda (spec)
  361.                       (let ((pat (car spec)))
  362.                         (create-variable (if (atom? pat) pat (car pat)))))
  363.                      specs)
  364.           (map (lambda (spec)
  365.                  (let ((pat (car spec)))
  366.                    (cond ((atom? pat) (cadr spec))
  367.                          (else `(,(t-syntax 'named-lambda) ,(car pat) ,(cdr pat)
  368.                                    . ,(cdr spec))))))
  369.                specs)))
  370.  
  371. ;;; (BLOCK . expressions)
  372. ;;; Handled by MAKE-BLOCK
  373.  
  374. (define-compiler-syntax (block . exp-list) (syntax shape)
  375.   (make-block exp-list syntax shape))
  376.  
  377. ;;; Local syntax
  378. ;;; Warn the luser and do what you can.
  379.  
  380. (define-compiler-syntax (define-local-syntax . spec) (syntax shape)
  381.   (set-local-syntax syntax spec)
  382.   (orbit-warning
  383.     '"DEFINE-LOCAL-SYNTAX not at top level. It will not have proper scope.")
  384.   (return (create-primop-node primop/undefined) nil nil))
  385.  
  386. ;;; Let syntax
  387.  
  388. (define-compiler-syntax (let-syntax specs . body) (syntax shape)
  389.   (let ((new-syntax (make-syntax-table syntax nil)))
  390.     (walk (lambda (spec) (set-local-syntax new-syntax spec))
  391.           specs)
  392.     (make-block body new-syntax shape)))
  393.  
  394. ;;; (OBJECT <proc>
  395. ;;;   ((<op1> . <args1>) . <method1>)
  396. ;;;      ...
  397. ;;;   ((<opN> . <argsN>) . <methodN>))
  398. ;;; =>
  399. ;;; (OBJECT <proc>
  400. ;;;         (<op1> ... <opN>)
  401. ;;;         ((LAMBDA (() () () . <args1>) . <method1>)
  402. ;;;             ...
  403. ;;;          (LAMBDA (() () () . <argsN>) . <methodN>)))
  404. ;;;
  405. ;;;   <op> may be a call in which case we eventually lose.
  406. ;;;
  407. ;;; (OBJECT (LAMBDA ...)
  408. ;;;   ((IDENTIFICATION SELF) '<name>)) compiles as LAMBDA with name <name>
  409. ;;;
  410.  
  411. (define-compiler-syntax (object proc . specs) (syntax shape)
  412.   (cond ;((and (pair? proc)
  413.         ;      (syntax-reference? (car proc) syntax/lambda syntax)
  414.         ;      (fx= 1 (length specs))
  415.         ;      (identification-method (car specs) syntax shape))
  416.         ; => (lambda (name)
  417.         ;      (destructure (((#f vars . body) proc))
  418.         ;        (alpha-lambda name vars body syntax shape))))
  419.         ((not (every? (lambda (x)
  420.                         (simple-object-method? x shape))
  421.                       specs))
  422.          (make-object-using-macro proc specs syntax shape))
  423.         (else                           
  424.          (alpha-object proc specs syntax shape))))
  425.  
  426. (define (alpha-object proc specs syntax shape)
  427.   (receive (proc-node c-parent c-role)
  428.            (->node proc syntax shape)
  429.     (cond ((call-node? proc-node)
  430.            (alpha-object-bail-out proc-node c-parent c-role specs
  431.                                   syntax shape))
  432.           ((not (or (lambda-node? proc-node)
  433.                     (known-literal? proc-node)))
  434.            (make-object-using-macro proc-node specs syntax shape))
  435.           (else
  436.            (receive (ops methods)
  437.                     (parse-object-specs specs syntax shape)
  438.              (let ((node (create-object-node nil (length ops))))
  439.                (relate-object-ops node ops)
  440.                (relate-object-methods node methods)
  441.                (relate object-proc node proc-node)
  442.                (return node nil nil)))))))
  443.  
  444. (define (known-literal? node)
  445.   (or (literal-node? node)
  446.       (and (reference-node? node)
  447.            (let ((var (reference-variable node)))
  448.              (and (variable-definition var)
  449.                   (eq? (get-definition-type (variable-definition var) node)
  450.                        'literal))))))
  451.  
  452. (define (make-object-using-macro proc specs syntax shape)
  453.   (->node (expand-object-form (cons proc specs))
  454.           syntax shape))
  455.  
  456. (define (alpha-object-bail-out proc-node pc-parent pc-role specs syntax shape)
  457.   (let ((p-val (create-variable 'v)))
  458.     (receive (node c-parent c-role)
  459.              (make-object-using-macro p-val specs syntax shape)
  460.       (let-nodes ((l1 (#f (p-val p-val)) node))
  461.         (relate pc-role pc-parent l1)
  462.         (return proc-node c-parent c-role)))))
  463.  
  464. ;;; Is SPEC of the form ((IDENTIFICATION SELF) '<symbol>) ?
  465.  
  466. ;(define (identification-method spec syntax shape)
  467. ;  (destructure ((((op #f . rest) form . r-forms) spec))
  468. ;    (if (and (eq? op 'identification)
  469. ;             (null? rest)
  470. ;             (null? r-forms)
  471. ;             (pair? form)
  472. ;             (syntax-reference? (car form) syntax/quote syntax)
  473. ;             (symbol? (cadr form)))
  474. ;        (cadr form)
  475. ;        nil)))
  476.  
  477. ;(define (syntax-reference? form desc syntax)
  478. ;  (or (eq? desc form)
  479. ;      (and (symbol? form)
  480. ;           (eq? desc (syntax-table-entry syntax form)))))
  481.  
  482. ;;; ((OP . ARGS) . BODY)
  483.  
  484. (define (simple-object-method? exp shape)
  485.   (and (pair? exp)
  486.        (pair? (car exp))
  487.        (symbol? (caar exp))
  488.        (not (variable-binder (obtain-variable shape (caar exp))))))
  489.  
  490. ;;; Parse SPECS into a list of operation nodes and method nodes.
  491.  
  492. (define (parse-object-specs specs syntax shape)
  493.   (iterate loop ((specs specs) (ops '()) (methods '()))
  494.     (cond ((null? specs)
  495.            (return (reverse! ops) (reverse! methods)))
  496.           (else
  497.            (destructure ((((op state . vars) . body) (car specs)))
  498.              (let ((op (->value-node op syntax shape))
  499.                    (method (->value-node (make-method state vars body)
  500.                                          syntax shape)))
  501.                (loop (cdr specs)
  502.                      (cons-from-freelist op ops)
  503.                      (cons-from-freelist method methods))))))))
  504.  
  505. ;;; Parse a method clause.  There are two forms of these.
  506.  
  507. (define (make-method state vars body)
  508.   (cond ((atom? state)        ; old form
  509.          `(,syntax/lambda (,state . ,vars)   
  510.                (,syntax/declare ignorable ,state)
  511.            (,primop/remove-state-object)
  512.                . ,body))
  513.         ((fxn= 2 (length state))
  514.          (error "bad syntax in state section of method clause ~S" state))
  515.         (else
  516.          (destructure (((self obj) state))
  517.           `(,syntax/lambda (,self . ,vars)  
  518.              ((,syntax/lambda (,obj)  . ,body)
  519.           (,primop/remove-state-object)))))))
  520.  
  521. ;;; (THE-ENVIRONMENT)
  522. ;;; This becomes a reference to the special variable *THE-ENVIRONMENT* that
  523. ;;; the compiler knows about.
  524.  
  525. (define-compiler-syntax (the-environment) (syntax shape)
  526.   (return (create-reference-node *the-environment*) nil nil))
  527.  
  528. ;;; The following are not yet (and may never be) implemented:
  529.  
  530. ;;; (let-reference ((a x) (b y)) ...)
  531. ;;;   ==>  (*let-reference (lambda (a b) ...)
  532. ;;;                        (locative x)
  533. ;;;                        (locative y))
  534.  
  535. ;;; (locale () ... (define a x) ... (define b y) ...)
  536. ;;;   ==>  (labels ((a (block ... x))
  537. ;;;                 (b (block ... y)))
  538. ;;;          ...)
  539.  
  540. ;;; (locale var . body)
  541. ;;;   ==>  (let ((env (make-locale (environment))))
  542. ;;;          (((expression (lambda (var) . body)) env) env)
  543.  
  544. ;;; (expression E) ==> (*expression (lambda (env ... free vars ...) E))
  545. ;;; (environment)  ==> (*environment outer-env '(name1 ...) var1 ...)
  546. ;;; (define-unless var pred thunk) ==> (*define-unless env 'var pred thunk)
  547.  
  548.  
  549.